home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / HEAP_UTL / HDEB20S / USEHDEB.PAS < prev    next >
Pascal/Delphi Source File  |  1995-04-17  |  10KB  |  344 lines
  1. {$B-,I-,N-,O-,P-,Q-,R-,S-,T-,V-,W-,X+}
  2. Unit USEHDEB;
  3.  
  4. interface
  5.  
  6. implementation
  7.  
  8. {$IFOPT D+}
  9.  
  10. {$DEFINE USE_SHAREWARE}              {<<  see README.TXT   }
  11. {not $DEFINE GERMAN_LANG}            {<<  for the          }
  12. {$DEFINE GETDEBUGINFO}               {<<  dokumentation    }
  13. {not $DEFINE REPORT_TO_FILE}         {<<  of these         }
  14. {not $DEFINE SWITCH_TO_LASTMODE}     {<<  switches !       }
  15.  
  16. {$IFDEF DPMI}    {$DEFINE WIN_OR_DPMI} {$ENDIF}
  17. {$IFDEF WINDOWS} {$DEFINE WIN_OR_DPMI} {$ENDIF}
  18.  
  19. uses
  20. {$IFDEF WINDOWS}
  21.      WinCrt,
  22. {$ELSE}
  23.      crt, drivers,
  24. {$ENDIF}
  25. {$IFDEF WIN_OR_DPMI}
  26.      WinProcs, Strings,
  27. {$ENDIF}
  28. {$IFDEF USE_SHAREWARE}
  29.      HDeb7S;
  30. {$ELSE}
  31.      HDeb7F;
  32. {$ENDIF}
  33.  
  34. const
  35.   DumpFileName = 'HEAPDEB.DMP'; {only used if REPORT_TO_FILE-Switch defined}
  36.  
  37. var
  38.   OldExitProc: pointer;
  39.  
  40. procedure DumpReport;
  41. type
  42.   PtrRec = record
  43.      Ofs, Seg: Word;
  44.   end;
  45. var
  46.   A:  array[0..9] of longint;
  47. {$IFDEF WINDOWS}
  48.   S:  array[0..80] of char;
  49. const
  50.   S4: array[1..5] of char = '    '#0; {indx from 1 for comatibility with pas-str}
  51. var
  52.   S5: array[0..5] of char;
  53.   SFile: array[0..12] of char;
  54.   SLine: array[0..5] of char;
  55. {$ELSE}
  56.   S:  string;
  57. const
  58.   S4: string[4] = '    ';
  59. var
  60.   S5: string[5];
  61.   SFile: string[12];
  62.   SLine: string[5];
  63. {$ENDIF}
  64.   C: Char ;
  65.   AEntry: PHeapDebEntry;
  66.   L: LongInt;
  67.   i: Integer;
  68.  
  69. const
  70. {$IFNDEF GERMAN_LANG}
  71.     MessageHello      = 'HEAP DEBUGGER DIAGNOSIS:';
  72.     MessageList       = 'list (Y/N) ? ';
  73.     MessageContList   = 'press any key to continue list or ESC to abort';
  74.     MessageLimitEx    = 'Shareware-limit exceeded!'#13#10'Only 50 pointers were registered!';
  75.     MessageHeadLine   =
  76.     '   No    Pointer   Size  Flags            Caller          File   Line';
  77. {$ELSE}
  78.     MessageHello      = 'HEAP DEBUGGER DIAGNOSE:';
  79.     MessageList       = 'auflisten (J/N) ? ';
  80.     MessageContList   = 'zum Fortsetzen eine Taste druecken oder ESC zum Abbrechen';
  81.     MessageLimitEx    = 'Shareware-Limit ueberschritten!'#13#10'Es wurden nur 50 pointer verarbeitet!';
  82.     MessageHeadLine   =
  83.     '   Nr    Pointer   Size  Flags          Aufrufer         Datei  Zeile';
  84. {$ENDIF}
  85.  
  86. {$IFDEF WINDOWS}
  87.     MessagePtrNo      = '%lu';
  88.     MessageReport     =
  89.     '%5s  %04lx:%04lx  %5lu  %s    %04lx[%04lx]:%04lx  %12s  %5s';
  90. {$ELSE}
  91.     MessagePtrNo      = '%d';
  92.     MessageReport     =
  93.     '%5s  %04x:%04x  %5d  %s    %04x[%04x]:%04x  %12s  %5s';
  94. {$ENDIF}
  95.  
  96. {$IFDEF WINDOWS}
  97.   {$IFNDEF GERMAN_LANG}
  98.     MessageHalt       = 'program stopped by HALT(%lu)';
  99.     MessageRTE        = 'runtime-error %03lu at %04lx:%04lx, file: %s line: %s ';
  100.     MessageInternalEr = 'internal error %lu occured in Heap Debugger';
  101.     MessagePtrReg     = '%lu pointers were registered';
  102.     MessageDebEntries = '%lu debug-entries available';
  103. {$ELSE}
  104.     MessageHalt       = 'Programm durch HALT(%lu) gestoppt';
  105.     MessageRTE        = 'Laufzeitfehler %03lu bei %04lx:%04lx, Datei: %s Zeile: %s ';
  106.     MessageInternalEr = 'interner Fehler %lu im Heap Debugger aufgetreten';
  107.     MessagePtrReg     = '%lu Pointer wurden registiert';
  108.     MessageDebEntries = '%lu Debug-Eintraege vorhanden';
  109.   {$ENDIF}
  110.  
  111.   procedure FormatStr(DestStr, FormatStr: PChar; var ArgList);
  112.   begin
  113.     wvsprintf(DestStr, FormatStr, ArgList);
  114.   end;
  115. {$ELSE}
  116.   {$IFNDEF GERMAN_LANG}
  117.     MessageHalt       = 'program halted by HALT(%d)';
  118.     MessageRTE        = 'runtime-error %03d at %04x:%04x, file: %s line: %s ';
  119.     MessageInternalEr = 'internal error %d occured in Heap Debugger';
  120.     MessagePtrReg     = '%d pointers were registered';
  121.     MessageDebEntries = '%d debug-entries available';
  122.   {$ELSE}
  123.     MessageHalt       = 'Programm durch HALT(%d) gestoppt';
  124.     MessageRTE        = 'Laufzeitfehler %03d bei %04x:%04x, Datei: %s Zeile: %s ';
  125.     MessageInternalEr = 'interner Fehler %d im Heap Debugger aufgetreten';
  126.     MessagePtrReg     = '%d Pointer wurden registiert';
  127.     MessageDebEntries = '%d Debug-Eintraege vorhanden';
  128.   {$ENDIF}
  129. {$ENDIF}
  130.  
  131. {$IFDEF WINDOWS}
  132.   procedure GetSourcePos(Address: pointer; Filename0T, LineNr0T: PChar);
  133.   var
  134.     FileName: String[12];
  135.     LineNr: String[5];
  136. {$ELSE}
  137.   procedure GetSourcePos(Address: pointer; var Filename, LineNr: string);
  138. {$ENDIF}
  139.       function ModuleFileName: String;
  140. {$IFDEF MSDOS}
  141.       begin
  142.         ModuleFileName := ParamStr(0);
  143.       end;
  144. {$ELSE}
  145.       var
  146.         Buff: Array[0..127] of char;
  147.       begin
  148.         GetModuleFileName(System.HInstance, Buff, Sizeof(Buff)-1);
  149.         ModuleFileName := StrPas(Buff);
  150.       end;
  151. {$ENDIF}
  152.   var w: word;
  153.   begin
  154. {$IFNDEF GERMAN_LANG}
  155.     FileName := 'unavailable';
  156. {$ELSE}
  157.     FileName := 'keine Info.';
  158. {$ENDIF}
  159.     LineNr   := '' ;
  160. {$IFDEF GETDEBUGINFO}
  161.     if GetDebugInfoRes = drNotInit then
  162.       InitDebugInfo(ModuleFileName);
  163.     if (GetDebugInfoRes <> drInvalidEXE)   and
  164.        (GetDebugInfoRes <> drInfoNotFound) then
  165.     begin
  166.       FileName := '           ?';
  167.       LineNr   := '    ?' ;
  168.  
  169. {$IFDEF USE_SHAREWARE}
  170.       HDeb7S.GetSourcePos(Address, Filename, w);
  171. {$ELSE}
  172.       HDeb7F.GetSourcePos(Address, Filename, w);
  173. {$ENDIF}
  174.       if GetDebugInfoRes = drOK then Str(w, LineNr);
  175.     end;
  176. {$ENDIF}
  177. {$IFDEF WINDOWS}
  178.     StrPCopy(FileName0T, FileName);
  179.     StrPCopy(LineNr0T, LineNr);
  180. {$ENDIF}
  181.   end;
  182.  
  183. var
  184.   DumpFile: Text {$IFNDEF REPORT_TO_FILE} absolute System.Output {$ENDIF};
  185.  
  186. begin
  187.   SuspendHeapdeb := true;
  188.  
  189. {$IFNDEF REPORT_TO_FILE}
  190.  {$IFNDEF WINDOWS}
  191.   DirectVideo := false; {so output is visible in graphicmode also}
  192.   {$IFDEF SWITCH_TO_LASTMODE}
  193.   Textmode(LastMode);
  194.   {$ENDIF}
  195.  {$ENDIF}
  196. {$ELSE}
  197.   Assign(DumpFile, DumpFileName);
  198.   Append(DumpFile);
  199.   if IOResult <> 0 then Rewrite(DumpFile);
  200. {$ENDIF}
  201.  
  202.   writeln(DumpFile, MessageHello);
  203.  
  204.   if ExitCode <> 0 then
  205.   begin
  206.     A[0] := ExitCode;
  207.     if ErrorAddr = nil then
  208.       FormatStr(S, MessageHalt, A)
  209.     else
  210.     begin
  211.       A[1] := PtrRec(ErrorAddr).Seg;
  212.       A[2] := PtrRec(ErrorAddr).Ofs;
  213.       GetSourcePos(ErrorAddr, SFile, SLine);
  214.       A[3] := Longint(@SFile);
  215.       A[4] := Longint(@SLine);
  216.       FormatStr(S, MessageRTE, A);
  217.       ErrorAddr := nil;
  218.     end;
  219.     writeln(DumpFile, S);
  220.   end
  221.   else
  222.   begin
  223.     if HeapDebInternalError = -1 then
  224.       writeln(DumpFile, MessageLimitEx)
  225.     else
  226.       if HeapDebInternalError > 0 then
  227.       begin
  228.         A[0] := HeapDebInternalError;
  229.         FormatStr(S, MessageInternalEr, A);
  230.         writeln(DumpFile, S);
  231.       end;
  232.  
  233.     FormatStr(S, MessagePtrReg, HeapDebTotalPtrCount);
  234.     writeln (DumpFile, S);
  235.     FormatStr(S, MessageDebEntries, HeapDebEntriesAvail);
  236.     Writeln (DumpFile, S);
  237.  
  238.     if HeapDebEntriesAvail > 0 then
  239.     begin
  240. {$IFNDEF REPORT_TO_FILE}
  241.       Write (DumpFile, MessageList);
  242.       C := ReadKey;
  243.       writeln (DumpFile, C);
  244.       if Upcase (C) = 'N' then Exit;
  245. {$ENDIF}
  246.       AEntry := nil;
  247.       i := 0;
  248.       while HeapDebReport(AEntry) <> nil do
  249.       begin
  250. {$IFNDEF REPORT_TO_FILE}
  251.         if i = 20 then
  252.         begin
  253.           i := 0;
  254.           writeln(DumpFile, MessageContList);
  255.           if readkey = #27 then Exit;
  256.         end;
  257. {$ENDIF}
  258.         if i = 0 then
  259.         begin
  260.           writeln(DumpFile, '');
  261.           writeln(DumpFile, MessageHeadLine);
  262.         end;
  263.         inc(i);
  264.         with AEntry^ do
  265.         begin
  266.           if No = 0 then
  267.             FillChar(S5, SizeOf(S5), #0)
  268.           else
  269.           begin
  270.             A[0] := No;
  271.             FormatStr(S5, MessagePtrNo, A);
  272.           end;
  273.           A[0] := longint(@S5);
  274.           A[1] := PtrRec(Ptr).Seg;
  275.           A[2] := PtrRec(Ptr).Ofs;
  276.           A[3] := Size;
  277.           S4[1] := ' '; S4[2] := ' '; S4[3] := ' '; S4[4] := ' ';
  278.           if Flags and hdflagIsObject        > 0 then S4[1] := 'O';
  279.           if Flags and hdflagFreeCall        > 0 then S4[2] := 'F';
  280.           if Flags and hdflagWrongSizeOnFree > 0 then S4[3] := 'S';
  281.           if Flags and hdflagNoMatchingGet   > 0 then S4[4] := 'M';
  282.           A[4] := longint(@S4);
  283.           A[5] := PtrRec(Caller).Seg;
  284.           A[6] := AktSeg;
  285.           A[7] := PtrRec(Caller).Ofs;
  286.           GetSourcePos(Caller, SFile, SLine);
  287.           A[8] := Longint(@SFile);
  288.           A[9] := Longint(@SLine);
  289.           FormatStr(S, MessageReport, A);
  290.           writeln(DumpFile, S);
  291. {$IFNDEF REPORT_TO_FILE}
  292.           if Keypressed and (Readkey = #27) then Exit;
  293. {$ENDIF}
  294.         end;
  295.       end;
  296.     end;
  297.   end;
  298. {$IFNDEF REPORT_TO_FILE}
  299.  {$IFNDEF WINDOWS}
  300.   ReadKey;
  301.  {$ENDIF}
  302. {$ELSE}
  303.   Close(DumpFile);
  304. {$ENDIF}
  305. end;
  306.  
  307. procedure LocalExitProc; far;
  308. var
  309.   SaveInOutRes: Integer;
  310. begin
  311.   ExitProc := OldExitProc;
  312.   SaveInOutRes := InOutRes;
  313.   InOutRes := 0; {force ok}
  314.   DumpReport;
  315.   HeapDebDone;
  316.   InOutRes := SaveInOutRes; {a later ExitProc might like to know this}
  317. end;
  318.  
  319. begin
  320. {$IFDEF WINDOWS}
  321.   if HPrevInst = 0 then
  322. {$ENDIF}
  323.     if HeapDebInit([]) then
  324.     begin
  325.       OldExitProc := ExitProc;
  326.       ExitProc := @LocalExitProc;
  327.     end
  328.     else
  329.     begin
  330. {$IFNDEF REPORT_TO_FILE}
  331.  {$IFNDEF WINDOWS}
  332.       DirectVideo := false; {so output is visible in graphicmode also}
  333.  {$ENDIF}
  334.  {$IFNDEF GERMAN_LANG}
  335.       writeln('Unable to initialize Heap Debugger !');
  336.  {$ELSE}
  337.       writeln('Heap Debugger konnte nicht initialisiert werden !');
  338.  {$ENDIF}
  339. {$ENDIF}
  340.       Halt;
  341.     end;
  342. {$ENDIF (d+)}
  343. end.
  344.